home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d18 / vmmngr.arc / VMM.IN2 < prev    next >
Text File  |  1990-07-16  |  23KB  |  705 lines

  1. {*********************************************************}
  2. {*                   VMM.IN2 1.00                        *}
  3. {*********************************************************}
  4.  
  5.   constructor Dynarray.Init(MaxElements, ElementSize, Incr : Word);
  6.     {-Called when a dynamic array is created}
  7.   begin
  8.    if (not Root.init) then
  9.       Fail;
  10.    if  (ElementSize = 0)
  11.     or (Incr = 0)
  12.     or (Incr > MaxElements)
  13.     or (MaxElements = 0)
  14.     or (LongInt(ElementSize)*Incr > MaxHeapAlloc)
  15.     or (LongInt(MaxElements)*ElementSize > MaxHeapAlloc) then begin
  16.        Done;
  17.        InitStatus := epFatal+ecBadParam;
  18.        Fail;
  19.    end;
  20.  
  21.    daBase := nil;
  22.    daElemSize := ElementSize;
  23.    daArraySize:= 0;
  24.    daInc := Incr;
  25.    daMaxIndex := MaxElements-1;
  26.    daValidElems := 0;
  27.    daStatus := 0;
  28.   end;
  29.  
  30.   destructor DynArray.Done;
  31.     {-Free memory occupied by the array}
  32.   begin
  33.    Clear;
  34.    Root.Done;
  35.   end;
  36.  
  37.   function DynArray.GetStatus : Word;
  38.     {-Return and reset array status}
  39.   begin
  40.    GetStatus := daStatus;
  41.    daStatus := 0;
  42.   end;
  43.  
  44.   function DynArray.PeekStatus : Word;
  45.     {-Return array status}
  46.   begin
  47.    PeekStatus := daStatus;
  48.   end;
  49.  
  50.   procedure DynArray.Error(Code : Word);
  51.     {-Assign error code}
  52.   begin
  53.     daStatus := Code;
  54.   end;
  55.  
  56.   procedure DynArray.SetElem(Index : Word; var Elem);
  57.     {-Set an array element to a given value; Increase size if necessary}
  58.   var
  59.     P           : Pointer;
  60.     NewSize     : Word;
  61.     NeededElems : Word;
  62.   begin
  63.     if Index > daMaxIndex then begin
  64.       Error(epFatal+ecBadParam);
  65.       Exit;
  66.     end;
  67.  
  68.     NeededElems := Succ(Index);
  69.     if NeededElems > daArraySize div daElemSize then begin
  70.     {The memory space allocated to the array must be increased}
  71.  
  72.       if (NeededElems mod daInc <> 0) or (Index = 0) then
  73.         NeededElems := Succ(NeededElems div daInc) * daInc;
  74.       if NeededElems > Succ(daMaxIndex) then
  75.         NeededElems := Succ(daMaxIndex);     {No superfluous allocation}
  76.       NewSize := NeededElems*daElemSize;
  77.       if UserGetMem(P, NewSize) then begin
  78.         FillChar(AddWordToPtr(P, daArraySize)^, NewSize-daArraySize, 0);
  79.         Move(daBase^, P^, daArraySize);      {Data transfer}
  80.         UserFreeMem(daBase, daArraySize);    {The bigger daIncr, the lesser}
  81.         daArraySize := NewSize;              { the heap will be fragmented}
  82.         daBase := P;
  83.       end
  84.       else begin
  85.         Error(epFatal+ecOutOfMemory);
  86.         Exit;
  87.       end;
  88.     end;
  89.  
  90.     if Succ(Index) > daValidElems then
  91.       daValidElems := Succ(Index);
  92.  
  93.     {Now stores the element data into the array}
  94.     Move(Elem, AddWordToPtr(daBase, daElemSize*Index)^, daElemSize);
  95.   end;
  96.  
  97.   procedure DynArray.GetElem(Index : Word; var Elem);
  98.     {-Return the indexth element}
  99.   begin
  100.     if Succ(LongInt(Index)) > daValidElems then
  101.       Error(epFatal+ecBadParam)
  102.     else
  103.       Move(AddWordToPtr(daBase, daElemSize*Index)^, Elem, daElemSize);
  104.   end;
  105.  
  106.   function DynArray.GetElemSize : Word;
  107.     {-Return size of an element}
  108.   begin
  109.     GetElemSize := daElemSize;
  110.   end;
  111.  
  112.   function DynArray.GetArraySize : Word;
  113.     {-Return actual size of array}
  114.   begin
  115.     GetArraySize := daArraySize;
  116.   end;
  117.  
  118.   function DynArray.GetMaxIndex : Word;
  119.     {-Return maximum index allowed}
  120.   begin
  121.    GetMaxIndex := daMaxIndex;
  122.   end;
  123.  
  124.   function DynArray.GetValidElems : Word;
  125.     {-Return number of valid elements}
  126.   begin
  127.    GetValidElems := daValidElems;
  128.   end;
  129.  
  130.   procedure DynArray.Shrink(ElemNb : Word);
  131.     {-Shrink array size to ElemNb elements and discard exceeding elements}
  132.   var
  133.     P          : pointer;
  134.     NewSize    : Word;
  135.     SaveElemNb : Word;
  136.   begin
  137.     if ElemNb = 0 then begin
  138.       Clear;
  139.       Exit;
  140.     end;
  141.     if ElemNb >= daArraySize div daElemSize then
  142.       Exit;
  143.     SaveElemNb := ElemNb;
  144.     if ElemNb mod daInc <> 0 then
  145.       ElemNb := Succ(ElemNb div daInc) * daInc;
  146.     NewSize := ElemNb*daElemSize;
  147.     if NewSize < daArraySize then
  148.     {Need to reallocate a smaller buffer}
  149.       if UserGetMem(P, NewSize) then begin
  150.         Move(daBase^, P^, NewSize);         {No need to fill with nulls since}
  151.         UserFreeMem(daBase, daArraySize);   { it's a smaller block}
  152.         daArraySize := NewSize;
  153.         daBase := P;
  154.       end
  155.       else begin
  156.         Error(epFatal+ecOutOfMemory);
  157.         Exit;
  158.       end;
  159.     {No reallocation - just need to adjust daValidElems}
  160.     if daValidElems > SaveElemNb then
  161.       daValidElems := SaveElemNb;
  162.   end;
  163.  
  164.   procedure DynArray.Clear;
  165.     {-Reset array to minimum size and discard all elements}
  166.   begin
  167.    UserFreeMem(daBase, daArraySize);
  168.    daArraySize := 0;
  169.    daValidElems := 0;
  170.    daStatus := 0;
  171.   end;
  172.  
  173.   constructor DynArray.Load(var S : IdStream);
  174.     {-Load a dynamic array from a stream}
  175.   begin
  176.    daBase := nil;
  177.    if not Root.Init then
  178.      Fail;
  179.    {Read characteristics of dynamic array}
  180.    S.ReadRange(daElemSize, daBase);
  181.    if S.PeekStatus <> 0 then begin
  182.      Done;
  183.      Fail;
  184.    end;
  185.    {Allocates memory to store array data}
  186.    if not UserGetMem(daBase, daArraySize) then begin
  187.      Done;
  188.      InitStatus := epFatal+ecOutOfMemory;
  189.      Fail;
  190.    end;
  191.    {Now read array data}
  192.    S.Read(daBase^, daArraySize);
  193.    if S.PeekStatus <> 0 then begin
  194.      Done;
  195.      Fail;
  196.    end;
  197.   end;
  198.  
  199.   procedure DynArray.Store(var S : IdStream);
  200.     {-Store a dynamic array in a stream}
  201.   begin
  202.    {Write characteristics of dynamic array}
  203.    {Only daBase is not stored}
  204.    S.WriteRange(daElemSize, daBase);
  205.    {Write array data}
  206.    S.Write(daBase^, daArraySize);
  207.   end;
  208.  
  209.   procedure DynArrayStream(SPtr : IdStreamPtr);
  210.     {-Register all types needed for streams containing DynArrays}
  211.   begin
  212.     SPtr^.RegisterType(otDynArray, veDynArray, TypeOf(DynArray),
  213.                        @DynArray.Store, @DynArray.Load);
  214.   end;
  215.  
  216.   {---------------------------------------------------------------------}
  217.  
  218.   procedure VmmStaticQueue.Remove(var Element);
  219.     {-Remove first element found equal to Element from the queue}
  220.   {
  221.    This procedure is needed to maintain the LRU queue. The very nature of
  222.    the LRU algorithm is to push into the queue a VMM handle each time it is
  223.    dereferenced. So, if we make sure that this handle is deleted before
  224.    pushing it into the queue, when we lock it or when we free it, we'll also
  225.    be sure that the "Least Recently Used" handle will be the first one
  226.    to be popped out from the queue.
  227.    Since we are sure that the elements processed by a VmmStaticQueue are
  228.    always handles (i.e. WORDs) the CompElem function is not really needed
  229.    because we should only compare WORDs. Though, the CompElem function
  230.    allows the VmmStaticQueue to be used for other purposes.
  231.   }
  232.   var
  233.     Ptr   : Word;
  234.     Found : Boolean;
  235.   begin
  236.     if sqTail > sqHead then begin
  237.     {There is no wrap-around in the queue}
  238.       Ptr := sqHead;
  239.       Found := false;
  240.       while not Found and (Ptr < sqTail) do begin
  241.         Inc(Ptr, sqElSize);
  242.         Found := CompElem(Element, sqBase^[Ptr], sqElSize);
  243.       end;
  244.       if Found then begin
  245.       {Remove element}
  246.         Move(sqBase^[Ptr+sqElSize], sqBase^[Ptr], sqTail-Ptr);
  247.         sqDec(sqTail);
  248.       end;
  249.     end
  250.     else if not IsEmpty then begin
  251.       {First search from Head to end of buffer}
  252.       Ptr := sqHead;
  253.       Found := false;
  254.       while not Found and (Ptr < sqSize) do begin
  255.         Inc(Ptr, sqElSize);
  256.         Found := CompElem(Element, sqBase^[Ptr], sqElSize);
  257.       end;
  258.       if not Found then begin
  259.       {Search from beginning of buffer to Tail}
  260.         Ptr := 0;
  261.         repeat
  262.           Found := CompElem(Element, sqBase^[Ptr], sqElSize);
  263.           Inc(Ptr, sqElSize);
  264.         until Found or (Ptr >= sqTail);
  265.         Dec(Ptr, sqElSize);
  266.       end;
  267.       if Found then begin
  268.       {Remove element}
  269.         if (Ptr > sqHead) then begin
  270.         {A little bit trickier in that case - circular move}
  271.           Move(sqBase^[Ptr+sqElSize], sqBase^[Ptr], (sqSize-Ptr-sqElSize));
  272.           Move(sqBase^, sqBase^[sqSize-sqElSize], sqElSize);
  273.           Move(sqBase^[sqElSize], sqBase^, sqTail);
  274.         end
  275.         else
  276.           Move(sqBase^[Ptr+sqElSize], sqBase^[Ptr], sqTail-Ptr);
  277.         sqDec(sqTail);
  278.       end;
  279.     end;
  280.     {If not found does nothing}
  281.   end;
  282.  
  283.   function VmmStaticQueue.IsEmpty : Boolean;
  284.     {-Return true if queue is empty}
  285.   begin
  286.     IsEmpty := sqHead = sqTail;
  287.   end;
  288.  
  289.   {---------------------------------------------------------------------}
  290.  
  291.   constructor AbstractFreeList.Init(MaxElements, Incr : Word);
  292.     {-Initialize a dynamic array of FreeRecords}
  293.   begin
  294.    if not DynArray.Init(MaxElements, SizeOf(FreeRecord), Incr) then
  295.      Fail;
  296.   end;
  297.  
  298.   function AbstractFreeList.GetFreeEntrySize(Index : Word) : LongInt;
  299.     {-Return size of a free block}
  300.   begin
  301.     {This virtual method must be overridden by descendants}
  302.     Abstract;
  303.   end;
  304.  
  305.   function AbstractFreeList.SizeToEndPtr(OrgPtr : Pointer;
  306.                                          BlkSize : LongInt) : Pointer;
  307.     {-Given OrgPtr and block size, return new entry's EndPtr}
  308.   begin
  309.     {This virtual method must be overridden by descendants}
  310.     Abstract;
  311.   end;
  312.  
  313.   function AbstractFreeList.SizeToOrgPtr(EndPtr : Pointer;
  314.                                          BlkSize : LongInt) : Pointer;
  315.     {-Given OrgPtr, EndPtr and block size, return new entry's OrgPtr}
  316.   begin
  317.     {This virtual method must be overridden by descendants}
  318.     Abstract;
  319.   end;
  320.  
  321.   function AbstractFreeList.PtrIsEqual(P1, P2 : Pointer) : Boolean;
  322.     {-Return true if pointers can be merged to form a new freelist entry}
  323.   begin
  324.     {This virtual method must be overridden by descendants}
  325.     Abstract;
  326.   end;
  327.  
  328.   function AbstractFreeList.GetFreeEntry(BlkSize : Word) : Pointer;
  329.     {-Search free list for a free block, return a pointer to it}
  330.   var
  331.     CurIndex   : Word;
  332.     CurEntSize : LongInt;
  333.     CurFreeRec : FreeRecord;
  334.   begin
  335.     if daValidElems = 0 then begin
  336.       GetFreeEntry := nil;
  337.       Exit;
  338.     end
  339.     else begin
  340.       for CurIndex := 0 to Pred(daValidElems) do begin
  341.       {Scan free list for a block that is big enough}
  342.         GetElem(CurIndex, CurFreeRec);
  343.         if GetStatus <> 0 then begin
  344.           GetFreeEntry := nil;
  345.           Exit;
  346.         end;
  347.         CurEntSize := GetFreeEntrySize(CurIndex);
  348.         if CurEntSize > BlkSize then begin
  349.           {bigger than needed - shrink size of block}
  350.           GetFreeEntry := CurFreeRec.OrgPtr;
  351.           CurFreeRec.OrgPtr := SizeToOrgPtr(CurFreeRec.EndPtr, CurEntSize-BlkSize);
  352.           SetElem(CurIndex, CurFreeRec);
  353.           if (GetStatus = 0) and Sort then;
  354.           {Sort free list to make sure GetFreeEntry will always choose the}
  355.           { smallest possible block - this will prevent fragmentation}
  356.           Exit;
  357.         end
  358.         else if CurEntSize = BlkSize then begin  {Exact match}
  359.           GetFreeEntry := CurFreeRec.OrgPtr;
  360.           {Delete used entry}
  361.           RemoveFreeEntry(CurIndex);
  362.           if (GetStatus = 0) and Sort then;
  363.           Exit;
  364.         end;
  365.       end;
  366.       {We didn't find a free entry which size is >= BlkSize}
  367.       GetFreeEntry := nil;
  368.     end;
  369.   end;
  370.  
  371.   function AbstractFreeList.AddFreeEntry(ThisOrgP : Pointer;
  372.                                          BlkSize : LongInt) : LongInt;
  373.     {-Insert a new free block in the FreeList or merge it with an }
  374.     { existing one - return size of entry in FreeList}
  375.   var
  376.     SaveIndex   : Word;
  377.     CurIndex    : Word;
  378.     CurFreeRec  : FreeRecord;
  379.     ThisEndP    : Pointer;
  380.     FoundOne    : Boolean;
  381.     FoundTwo    : Boolean;
  382.     Found       : Boolean;
  383.     Pass        : 1..2;
  384.   label
  385.     AddIt;
  386.   begin
  387.     ThisEndP := SizeToEndPtr(ThisOrgP, BlkSize);
  388.     FoundOne := false;
  389.     FoundTwo := false;
  390.     if daValidElems = 0 then {Nothing to search for}
  391.       Goto AddIt;
  392.  
  393.     for Pass := 1 to 2 do begin
  394.     {All blocks combinations should be found in two passes}
  395.       CurIndex := 0;
  396.       Found := false;
  397.  
  398.       while (CurIndex <= Pred(daValidElems)) and not Found do begin
  399.         {search for a free list entry to combine with}
  400.         GetElem(CurIndex, CurFreeRec);
  401.         {does the EndPtr of our entry match the start of the current one ?}
  402.         if PtrIsEqual(ThisEndP, CurFreeRec.OrgPtr) then begin
  403.           CurFreeRec.OrgPtr := ThisOrgP;
  404.           Found := true;
  405.           {Save index for freelist update if second match found}
  406.           if Pass = 1 then begin
  407.             ThisEndP := CurFreeRec.EndPtr; {save it for next loop}
  408.             SaveIndex := CurIndex;
  409.             FoundOne := true;
  410.           end
  411.           else
  412.           {Second match found}
  413.             FoundTwo := true;
  414.         end
  415.         {does the OrgPtr of our entry match the ind of the current one ?}
  416.         else if PtrIsEqual(ThisOrgP, CurFreeRec.EndPtr) then begin
  417.           CurFreeRec.EndPtr := ThisEndP;
  418.           Found := true;
  419.           if Pass = 1 then begin
  420.             ThisOrgP := CurFreeRec.OrgPtr; {save it for next loop}
  421.             SaveIndex := CurIndex;
  422.             FoundOne := true;
  423.           end
  424.           else
  425.             FoundTwo := true;
  426.         end;
  427.         {go to next entry in the freelist or...}
  428.         if not Found then
  429.           Inc(CurIndex)
  430.         else begin
  431.           {...update entry in freeList}
  432.           SetElem(CurIndex, CurFreeRec);
  433.           if GetStatus <> 0 then
  434.             AddFreeEntry := 0
  435.           else
  436.             AddFreeEntry := GetFreeEntrySize(CurIndex);
  437.         end;
  438.       end;
  439.     end;
  440.  
  441. AddIt:
  442.  
  443.     if FoundTwo then
  444.     {We found two blocks to combine with ours - the first one has to be deleted}
  445.       RemoveFreeEntry(SaveIndex)
  446.     else if not FoundOne then begin
  447.     {No block combination was possible - add new entry to freelist}
  448.       CurFreeRec.OrgPtr := ThisOrgP;
  449.       CurFreeRec.EndPtr := SizeToEndPtr(ThisOrgP, BlkSize);
  450.       SetElem(daValidElems, CurFreeRec);
  451.       AddFreeEntry := GetFreeEntrySize(Pred(daValidElems));
  452.     end;
  453.  
  454.     if not ((GetStatus = 0) and Sort) then
  455.       AddFreeEntry := 0;
  456.     {Sort free list to make sure GetFreeEntry will always choose the}
  457.     { smallest possible block - this will prevent fragmentation}
  458.   end;
  459.  
  460.   procedure AbstractFreeList.RemoveFreeEntry(Index : Word);
  461.     {-Remove entry from the list and shrink list size}
  462.   var
  463.     LastIndex : Word;
  464.     F         : FreeRecord;
  465.   begin
  466.     if (daValidElems = 0) or (Index > daValidElems) then begin
  467.       Error(epFatal+ecBadParam);
  468.       Exit;
  469.     end;
  470.     LastIndex := Pred(daValidElems);
  471.     {Move last entry...}
  472.     GetElem(LastIndex, F);
  473.     {...to the entry to be deleted}
  474.     SetElem(Index, F);
  475.     {and shrink freelist by one element}
  476.     Shrink(LastIndex);
  477.   end;
  478.  
  479.   function AbstractFreeList.MaxFree : Longint;
  480.     {-Return size of largest free entry}
  481.   begin
  482.     {Since the free list is always sorted in block size order}
  483.     { the largest block available is always the last one}
  484.     if daValidElems > 0 then
  485.       MaxFree := GetFreeEntrySize(Pred(daValidElems))
  486.     else
  487.       MaxFree := 0;
  488.   end;
  489.  
  490.   procedure AbstractFreeList.QuickSort(L, R : Word);
  491.     {-Actual sort procedure called by Sort}
  492.   const
  493.     StackToKeep = 512;
  494.   var
  495.     i, j, p : LongInt;
  496.     Ei, Ej  : FreeRecord;
  497.   begin
  498.    if SPtr > StackToKeep then begin {Keep StackToKeep bytes free on stack}
  499.     i := L;                         {Each recursion uses approximately 50 bytes}
  500.     j := R;
  501.     p := (i+j) div 2;
  502.     repeat
  503.      while GetFreeEntrySize(i) < GetFreeEntrySize(p) do
  504.        Inc(i);
  505.      while GetFreeEntrySize(p) < GetFreeEntrySize(j) do
  506.        Dec(j);
  507.      if i <= j then begin {Swap elements}
  508.        GetElem(i, Ei);
  509.        GetElem(j, Ej);
  510.        SetElem(i, Ej);
  511.        SetELem(j, Ei);
  512.        Inc(i);
  513.        Dec(j);
  514.      end;
  515.     until i > j;
  516.     if L < j  then
  517.       QuickSort(L, j); {Recursive call with new boundaries}
  518.     IF i < R then
  519.       QuickSort(i, R);
  520.    end
  521.    else
  522.      Error(epNonFatal+ecOutOfMemory);
  523.   end;
  524.  
  525.   function AbstractFreeList.Sort : boolean;
  526.     {-Sort the free list in block size order}
  527.   var
  528.     Count : Word;
  529.   const
  530.     MaxCount = 3;
  531.   begin
  532.     Count := 0;
  533.     if daValidElems > 1 then
  534.       repeat
  535.         QuickSort(0, Pred(daValidElems));
  536.         Inc(Count);
  537.       until (PeekStatus = 0) or (Count = MaxCount);
  538.     Sort := GetStatus = 0;
  539.     {
  540.      Some explanations needed here. It's very important for the VMM that
  541.      the freelist sort succeeds. If not, MaxFree will not return the right
  542.      value and fragmentation will begin. The only reason for Sort to fail
  543.      is that we could run out of stack space. In that case the array remains
  544.      partially sorted. However, the number of recursions needed for a QuickSort
  545.      depends heavily on the initial order of items in the array. So, a
  546.      second (or a third) try on the partially sorted array may (will likely)
  547.      succeed. Moreover, freelists are sorted very often. Hence, the required
  548.      number of recursions will be very low.
  549.  
  550.      In most cases freelists will not be very big. So the SORT method will
  551.      succeed anyway. Some experiments showed that even very big arrays
  552.      can be sorted in 3 passes. In the very rare situations where 3 passes
  553.      are not enough, you may want to increase MaxCount to allow more passes.
  554.     }
  555.   end;
  556.  
  557.   {---------------------------------------------------------------------}
  558.  
  559.   function VmmRamFreeList.GetFreeEntrySize(Index : Word) : LongInt;
  560.     {-Return size of a free block}
  561.   var
  562.     F : FreeRecord;
  563.   begin
  564.     GetElem(Index, F);
  565.     if GetStatus = 0 then
  566.       with F do
  567.         GetFreeEntrySize := PtrToLong(EndPtr) - PtrToLong(OrgPtr)
  568.     else
  569.       GetFreeEntrySize := 0;
  570.   end;
  571.  
  572.   function VmmRamFreeList.SizeToEndPtr(OrgPtr : Pointer;
  573.                                        BlkSize : LongInt) : Pointer;
  574.     {-Given OrgPtr and block size, return new entry's EndPtr}
  575.   begin
  576.     {Assume BlkSize validity}
  577.     SizeToEndPtr :=AddLongToPtr(OrgPtr, BlkSize);
  578.   end;
  579.  
  580.   function VmmRamFreeList.SizeToOrgPtr(EndPtr : Pointer;
  581.                                        BlkSize : LongInt) : Pointer;
  582.     {-Given EndPtr and block size, return new entry's OrgPtr}
  583.   begin
  584.     {Assume BlkSize validity}
  585.     SizeToOrgPtr := LongToPtr(PtrToLong(EndPtr) - BlkSize);
  586.   end;
  587.  
  588.   function VmmRamFreeList.PtrIsEqual(P1, P2 : Pointer) : Boolean;
  589.     {-Return true if pointers can be merged to form a new freelist entry}
  590.   begin
  591.     PtrIsEqual := PtrToLong(P1) = PtrToLong(P2);
  592.   end;
  593.  
  594.   {---------------------------------------------------------------------}
  595.  
  596.   function VmmEmsFreeList.AddFreeEntry(ThisOrgP : Pointer;
  597.                                        BlkSize : Word) : LongInt;
  598.     {Override generic AddFreeEntry method because Ems need special handling}
  599.     { This method will deallocate an Ems frame when it is empty}
  600.   var
  601.     F        : FreeRecord;
  602.     Found    : Boolean;
  603.     CurIndex : Word;
  604.   begin
  605.     {Use generic method and if entire Ems page frame is free, deallocate handle}
  606.     if AbstractFreeList.AddFreeEntry(ThisOrgP, BlkSize) = MaxEmsBlock then begin
  607.       {Because the freelist has been sorted in block order size the new}
  608.       { entry is now necessarily the last one because it has the maximum}
  609.       { size - So we only have to free the handle of the last entry and}
  610.       { to remove it from the list}
  611.       GetElem(Pred(daValidElems), F);
  612.       if not DeAllocateEmsHandle(VmmPtrRec(F.OrgPtr).Seg) then
  613.         Error(epNonFatal+ecCantFreeEms)
  614.       else begin
  615.         {Remove entry from freelist - we remove the last one, no need to sort}
  616.         RemoveFreeEntry(Pred(daValidElems));
  617.         if PeekStatus <> 0 then
  618.           AddFreeEntry := 0;
  619.       end;
  620.     end;
  621.   end;
  622.  
  623.   function VmmEmsFreeList.GetFreeEntrySize(Index : Word) : LongInt;
  624.     {-Return size of a free block}
  625.   var
  626.     F : FreeRecord;
  627.   begin
  628.     GetElem(Index, F);
  629.     if GetStatus = 0 then
  630.       with F do
  631.         GetFreeEntrySize := VmmPtrRec(EndPtr).Ofs - VmmPtrRec(OrgPtr).Ofs
  632.     else
  633.       GetFreeEntrySize := 0;
  634.     {The segment part is assumed to be the same for EndPtr and OrgPtr}
  635.     { It is the Ems handle - a free entry in EmsFreeList cannot be > 64k}
  636.   end;
  637.  
  638.   function VmmEmsFreeList.SizeToEndPtr(OrgPtr : Pointer;
  639.                                        BlkSize : LongInt) : Pointer;
  640.     {-Given OrgPtr and block size, return new entry's EndPtr}
  641.   begin
  642.     {Assume BlkSize validity - entries cannot be greater than 64k}
  643.     Inc(VmmPtrRec(OrgPtr).Ofs, Word(BlkSize));
  644.     SizeToEndPtr := OrgPtr;
  645.     {The segment part is assumed to be the same for EndPtr and OrgPtr}
  646.     { It is the Ems handle}
  647.   end;
  648.  
  649.   function VmmEmsFreeList.SizeToOrgPtr(EndPtr : Pointer;
  650.                                        BlkSize : LongInt) : Pointer;
  651.     {-Given OrgPtr, EndPtr and block size, return new entry's OrgPtr}
  652.   begin
  653.     {Assume BlkSize validity - entries cannot be greater than 64k}
  654.     Dec(VmmPtrRec(EndPtr).Ofs, Word(BlkSize));
  655.     SizeToOrgPtr :=EndPtr;
  656.     {The segment part is assumed to be the same for EndPtr and OrgPtr}
  657.     { It is the Ems handle}
  658.   end;
  659.  
  660.   function VmmEmsFreeList.PtrIsEqual(P1, P2 : Pointer) : Boolean;
  661.     {-Return true if pointers can be merged to form a new freelist entry}
  662.   begin
  663.     PtrIsEqual := P1 = P2; {Segment (handle) and offset must be the same}
  664.   end;
  665.  
  666.   {---------------------------------------------------------------------}
  667.  
  668.   function VmmDskFreeList.GetFreeEntrySize(Index : Word) : LongInt;
  669.     {-Return size of a free block}
  670.   var
  671.     F       : FreeRecord;
  672.     Offsets : array [1..2] of LongInt absolute F;
  673.   begin
  674.     GetElem(Index, F);
  675.     if GetStatus = 0 then
  676.       GetFreeEntrySize := Offsets[2] - Offsets[1]
  677.     else
  678.       GetFreeEntrySize := 0;
  679.   end;
  680.  
  681.   function VmmDskFreeList.SizeToEndPtr(OrgPtr : Pointer;
  682.                                        BlkSize : LongInt) : Pointer;
  683.     {-Given OrgPtr and block size, return new entry's EndPtr}
  684.   var
  685.     BlockOrg : LongInt absolute OrgPtr;
  686.   begin
  687.     SizeToEndPtr := Pointer(BlockOrg + BlkSize);
  688.   end;
  689.  
  690.   function VmmDskFreeList.SizeToOrgPtr(EndPtr : Pointer;
  691.                                        BlkSize : LongInt) : Pointer;
  692.     {-Given OrgPtr, EndPtr and block size, return new entry's OrgPtr}
  693.   var
  694.     BlockEnd : LongInt absolute EndPtr;
  695.   begin
  696.     SizeToOrgPtr := Pointer(BlockEnd - BlkSize);
  697.   end;
  698.  
  699.   function VmmDskFreeList.PtrIsEqual(P1, P2 : Pointer) : Boolean;
  700.     {-Return true if pointers can be merged to form a new freelist entry}
  701.   begin
  702.     PtrIsEqual := P1 = P2; {LongInt(P1) = LongInt(P2)}
  703.   end;
  704.  
  705.